home *** CD-ROM | disk | FTP | other *** search
/ The PC-SIG Library 10 / The PC-Sig Library - Shareware for the IBM PC and Compatibles (PC-SIG)(Tenth Edition Disks 1-2804)(1991).iso / PC_SIGCD / 07 / 0 / DISK0709.ZIP / INSTACAL.PAS < prev    next >
Pascal/Delphi Source File  |  1988-01-05  |  25KB  |  849 lines
  1.  
  2.  
  3.  
  4. program INSTACAL;
  5.  
  6. {       INSTACAL.PAS - calendar generator written in Turbo Pascal
  7.  
  8. *******************************************************************************
  9. *                                                                             *
  10. *                                                                             *
  11. *                           INSTACAL - Version 2.2                            *
  12. *                                                                             *
  13. *                               Copyright 1988                                *
  14. *                                     by                                      *
  15. *                            James Michael Shellem                            *
  16. *                            Woodlyn, Pennsylvania                            *
  17. *                                                                             *
  18. *                                                                             *
  19. ******************************************************************************}
  20.  
  21. {$R+,U+,B-}
  22.  
  23. type
  24.    CALTYPE = array[1..66, 1..80] of CHAR;
  25.    STRING9 = string[9];
  26.  
  27.    REGS_TYPE = record
  28.       case INTEGER of
  29.          1 : (AX, BX, CX, DX, BP, SI, DI, DS, ES, FLAGS : INTEGER);
  30.          2 : (AL, AH, BL, BH, CL, CH, DL, DH : BYTE);
  31.       end;
  32.  
  33. var
  34.    CAL : CALTYPE;
  35.    YEARSTR  : string[4];
  36.    MONTHSTR : STRING9;
  37.    I, J, K,
  38.    WEEK,
  39.    MONTH,
  40.    YEAR : INTEGER;
  41.    OUTFILE : TEXT;
  42.    CHOICE,
  43.    RETURN,
  44.    RESPONSE,
  45.    OUTDEVICE,
  46.    RES : CHAR;
  47.    LOW, HIGH : BYTE;
  48.  
  49. {------------------------------------------------------------------------------}
  50.  
  51. procedure READFK(var CHOICE : CHAR;
  52.                  LOW, HIGH : BYTE);
  53.  
  54. {Read function key.}
  55.  
  56. var
  57.    REGS : REGS_TYPE;
  58.    I,
  59.    TEMP : INTEGER;
  60.    A : ARRAY[1..2] OF BYTE;
  61.  
  62. begin
  63.    REGS.AH := $1;
  64.    I := 1;
  65.    repeat
  66.          MSDOS(REGS);
  67.          A[I] := REGS.AL;
  68.          I := I + 1
  69.    until (I > 2) or (A[1] <> 0);
  70.    TEMP := (A[2] mod 256) - 10;
  71.    if not (A[2] in [LOW..HIGH]) then
  72.       WRITE(#8'  ');
  73.    WRITELN;
  74.    if (TEMP < 0) then
  75.       TEMP := TEMP + 10;
  76.    CHOICE := CHR(TEMP)
  77. end;
  78.  
  79. {------------------------------------------------------------------------------}
  80.  
  81. procedure READCH(var CHOICE : CHAR);
  82.  
  83. {Read key pressed.}
  84.  
  85. var
  86.    REGS : REGS_TYPE;
  87.  
  88. begin
  89.    REGS.AH := $1;
  90.    MSDOS(REGS);
  91.    if (REGS.AL = 0) then
  92.       begin
  93.          MSDOS(REGS);
  94.          WRITE(#8'  ')
  95.       end;
  96.    WRITELN;
  97.    CHOICE := CHR(REGS.AL)
  98. end;
  99.  
  100. {------------------------------------------------------------------------------}
  101.  
  102. procedure DRAW_WINDOW(X1, Y1, X2, Y2 : INTEGER);
  103.  
  104. var
  105.    X, Y : INTEGER;
  106.  
  107. begin
  108.    GOTOXY(X1, Y1);
  109.    for X := X1 to X2 do
  110.       WRITE(CHR(178));
  111.    for Y := Y1+1 to Y2-1 do
  112.       begin
  113.          GOTOXY(X1, Y);
  114.          WRITE(CHR(178));
  115.          GOTOXY(X2, Y);
  116.          WRITE(CHR(178))
  117.       end;
  118.  
  119.    GOTOXY(X1, Y2);
  120.    for X := X1 to X2 do
  121.       WRITE(CHR(178))
  122. end; {DRAW_WINDOW}
  123.  
  124. {------------------------------------------------------------------------------}
  125.  
  126. procedure INITIALIZE;
  127.  
  128. var
  129.    I, J : INTEGER;
  130.  
  131. begin
  132.    for I := 5 to 62 do
  133.       for J := 1 to 76 do
  134.          CAL[I, J] := ' ';
  135.    CLRSCR
  136. end;
  137.  
  138. {------------------------------------------------------------------------------}
  139.  
  140. procedure YEARCAL;
  141.  
  142. {Generate yearly calendar.}
  143.  
  144. const
  145.    N = 1;
  146.  
  147. var
  148.    TEMP : string[1];
  149.    START, I1, J1,
  150.    M, C, Y, L, K,
  151.    D, D1, D2, TEMP2, ERROR,
  152.    I, J, DAY, DAYS : INTEGER;
  153.    TS : string[1];
  154.  
  155. begin {YEARCAL}
  156.    I := 5;
  157.    K := YEAR div 1000;
  158.    STR(K:1, TEMP);
  159.    CAL[I, 38] := TEMP;
  160.    K := (YEAR mod 1000) div 100;
  161.    STR(K:1, TEMP);
  162.    CAL[I, 40] := TEMP;
  163.    K := (YEAR mod 100) div 10;
  164.    STR(K:1, TEMP);
  165.    CAL[I, 42] := TEMP;
  166.    K := YEAR mod 10;
  167.    STR(K:1, TEMP);
  168.    CAL[I, 44] := TEMP;
  169.    CAL[10, 13] := 'J';  CAL[10, 14] := 'A';  CAL[10, 15] := 'N';
  170.    CAL[10, 16] := 'U';  CAL[10, 17] := 'A';  CAL[10, 18] := 'R';
  171.    CAL[10, 19] := 'Y';
  172.    CAL[10, 37] := 'F';  CAL[10, 38] := 'E';  CAL[10, 39] := 'B';
  173.    CAL[10, 40] := 'R';  CAL[10, 41] := 'U';  CAL[10, 42] := 'A';
  174.    CAL[10, 43] := 'R';  CAL[10, 44] := 'Y';
  175.    CAL[10, 64] := 'M';  CAL[10, 65] := 'A';  CAL[10, 66] := 'R';
  176.    CAL[10, 67] := 'C';  CAL[10, 68] := 'H';
  177.    CAL[23, 14] := 'A';  CAL[23, 15] := 'P';  CAL[23, 16] := 'R';
  178.    CAL[23, 17] := 'I';  CAL[23, 18] := 'L';
  179.    CAL[23, 40] := 'M';  CAL[23, 41] := 'A';  CAL[23, 42] := 'Y';
  180.    CAL[23, 64] := 'J';  CAL[23, 65] := 'U';
  181.    CAL[23, 66] := 'N';  CAL[23, 67] := 'E';
  182.    CAL[36, 14] := 'J';  CAL[36, 15] := 'U';
  183.    CAL[36, 16] := 'L';  CAL[36, 17] := 'Y';
  184.    CAL[36, 38] := 'A';  CAL[36, 39] := 'U';  CAL[36, 40] := 'G';
  185.    CAL[36, 41] := 'U';  CAL[36, 42] := 'S';  CAL[36, 43] := 'T';
  186.    CAL[36, 62] := 'S';  CAL[36, 63] := 'E';  CAL[36, 64] := 'P';
  187.    CAL[36, 65] := 'T';  CAL[36, 66] := 'E';  CAL[36, 67] := 'M';
  188.    CAL[36, 68] := 'B';  CAL[36, 69] := 'E';  CAL[36, 70] := 'R';
  189.    CAL[49, 13] := 'O';  CAL[49, 14] := 'C';  CAL[49, 15] := 'T';
  190.    CAL[49, 16] := 'O';  CAL[49, 17] := 'B';  CAL[49, 18] := 'E';
  191.    CAL[49, 19] := 'R';
  192.    CAL[49, 37] := 'N';  CAL[49, 38] := 'O';  CAL[49, 39] := 'V';
  193.    CAL[49, 40] := 'E';  CAL[49, 41] := 'M';  CAL[49, 42] := 'B';
  194.    CAL[49, 43] := 'E';  CAL[49, 44] := 'R';
  195.    CAL[49, 62] := 'D';  CAL[49, 63] := 'E';  CAL[49, 64] := 'C';
  196.    CAL[49, 65] := 'E';  CAL[49, 66] := 'M';  CAL[49, 67] := 'B';
  197.    CAL[49, 68] := 'E';  CAL[49, 69] := 'R';
  198.    for MONTH := 1 to 12 do
  199.       begin
  200.          M := MONTH - 2;
  201.          if M <= 0 then
  202.             M := M + 12;
  203.          C := YEAR div 100;
  204.          L := 0;
  205.          if (YEAR mod 4) = 0 then
  206.             L := 1;
  207.          if ((YEAR mod 100) = 0) and ((YEAR mod 400) <> 0) then
  208.             L := 0;
  209.          Y := YEAR mod 100;
  210.          D1 := N + TRUNC(2.6 * M - 0.2) + Y + (Y div 4) + (C div 4);
  211.          D2 := 2 * C + (1 + L) * (M div 11);
  212.          if (WEEK = 1) then
  213.             D := 1 + (D1 - D2) mod 7
  214.          else
  215.             D := ((9 - WEEK) + (D1 - D2)) mod 7;
  216.          if (D < 1) then
  217.             D := D + 7;
  218.          case MONTH of
  219.             1, 3, 5, 7, 8, 10, 12 : DAYS := 31;
  220.             2 : if L = 1 then
  221.                    DAYS := 29
  222.                 else
  223.                    DAYS := 28;
  224.             4, 6, 9, 11 : DAYS := 30
  225.          end; {case}
  226.          case MONTH of
  227.             1 : begin
  228.                    I1 := 10;   J1 := 6
  229.                 end;
  230.             2 : begin
  231.                    I1 := 10;   J1 := 31
  232.                 end;
  233.             3 : begin
  234.                    I1 := 10;   J1 := 56
  235.                 end;
  236.             4 : begin
  237.                    I1 := 23;   J1 := 6
  238.                 end;
  239.             5 : begin
  240.                    I1 := 23;   J1 := 31
  241.                 end;
  242.             6 : begin
  243.                    I1 := 23;   J1 := 56
  244.                 end;
  245.             7 : begin
  246.                    I1 := 36;   J1 := 6
  247.                 end;
  248.             8 : begin
  249.                    I1 := 36;   J1 := 31
  250.                 end;
  251.             9 : begin
  252.                    I1 := 36;   J1 := 56
  253.                 end;
  254.            10 : begin
  255.                    I1 := 49;   J1 := 6
  256.                 end;
  257.            11 : begin
  258.                    I1 := 49;   J1 := 31
  259.                 end;
  260.            12 : begin
  261.                    I1 := 49;   J1 := 56
  262.                 end
  263.          end; {case}
  264.          I1 := I1 + 2;
  265.          case WEEK of
  266.             1 : begin
  267.                    CAL[I1, J1 + 1] := 's'; CAL[I1, J1 + 4] := 'm';
  268.                    CAL[I1, J1 + 7] := 't';
  269.                    CAL[I1, J1 + 10] := 'w';   CAL[I1, J1 + 13] := 't';
  270.                    CAL[I1, J1 + 16] := 'f';   CAL[I1, J1 + 19] := 's';
  271.                 end;
  272.             2 : begin
  273.                    CAL[I1, J1 + 1] := 'm'; CAL[I1, J1 + 4] := 't';
  274.                    CAL[I1, J1 + 7] := 'w';
  275.                    CAL[I1, J1 + 10] := 't';   CAL[I1, J1 + 13] := 'f';
  276.                    CAL[I1, J1 + 16] := 's';   CAL[I1, J1 + 19] := 's';
  277.                 end;
  278.             3 : begin
  279.                    CAL[I1, J1 + 1] := 't'; CAL[I1, J1 + 4] := 'w';
  280.                    CAL[I1, J1 + 7] := 't';
  281.                    CAL[I1, J1 + 10] := 'f';   CAL[I1, J1 + 13] := 's';
  282.                    CAL[I1, J1 + 16] := 's';   CAL[I1, J1 + 19] := 'm';
  283.                 end;
  284.             4 : begin
  285.                    CAL[I1, J1 + 1] := 'w'; CAL[I1, J1 + 4] := 't';
  286.                    CAL[I1, J1 + 7] := 'f';
  287.                    CAL[I1, J1 + 10] := 's';   CAL[I1, J1 + 13] := 's';
  288.                    CAL[I1, J1 + 16] := 'm';   CAL[I1, J1 + 19] := 't';
  289.                 end;
  290.             5 : begin
  291.                    CAL[I1, J1 + 1] := 't'; CAL[I1, J1 + 4] := 'f';
  292.                    CAL[I1, J1 + 7] := 's';
  293.                    CAL[I1, J1 + 10] := 's';   CAL[I1, J1 + 13] := 'm';
  294.                    CAL[I1, J1 + 16] := 't';   CAL[I1, J1 + 19] := 'w';
  295.                 end;
  296.             6 : begin
  297.                    CAL[I1, J1 + 1] := 'f'; CAL[I1, J1 + 4] := 's';
  298.                    CAL[I1, J1 + 7] := 's';
  299.                    CAL[I1, J1 + 10] := 'm';   CAL[I1, J1 + 13] := 't';
  300.                    CAL[I1, J1 + 16] := 'w';   CAL[I1, J1 + 19] := 't';
  301.                 end;
  302.             7 : begin
  303.                    CAL[I1, J1 + 1] := 's'; CAL[I1, J1 + 4] := 's';
  304.                    CAL[I1, J1 + 7] := 'm';
  305.                    CAL[I1, J1 + 10] := 't';   CAL[I1, J1 + 13] := 'w';
  306.                    CAL[I1, J1 + 16] := 't';   CAL[I1, J1 + 19] := 'f';
  307.                 end
  308.          end;
  309.          I1 := I1 + 1;
  310.          if (D = 1) then
  311.             START := J1
  312.          else
  313.             START := J1 - 3 + (3 * D);
  314.          I := I1;
  315.          J := START;
  316.          DAY := 1;
  317.          repeat
  318.             if ((DAY div 10) <> 0) then
  319.                begin
  320.                   TEMP2 := DAY div 10;
  321.                   STR(TEMP2:1, TS);
  322.                   CAL[I, J] := TS
  323.                end; {if}
  324.             TEMP2 := DAY mod 10;
  325.             STR(TEMP2:1, TS);
  326.             CAL[I, J + 1] := TS;
  327.             DAY := DAY + 1;
  328.             J := J + 3;
  329.             if J > (J1 + 19) then
  330.                begin
  331.                   I := I + 1;
  332.                   J := J1
  333.                end {if}
  334.          until (DAY > DAYS)
  335.       end; {for}
  336.  
  337.    for I := 1 to 4 do
  338.       WRITELN(OUTFILE);
  339.    for I := 5 to 62 do
  340.       begin
  341.          for J := 1 to 76 do
  342.             WRITE(OUTFILE, CAL[I, J]);
  343.          WRITELN(OUTFILE)
  344.       end; {for}
  345.    if (OUTDEVICE in ['6', '7']) then
  346.       WRITE(OUTFILE, #12);
  347.    INITIALIZE
  348. end; {YEARCAL}
  349.  
  350. {------------------------------------------------------------------------------}
  351.  
  352. procedure MONTHCAL(MONTH : INTEGER);
  353.  
  354. {Generate monthly calendar.}
  355.  
  356. const
  357.    N = 1;
  358.  
  359. var
  360.    START,
  361.    M, C, Y, L,
  362.    D, D1, D2, TEMP, ERROR,
  363.    I, J, DAY, DAYS : INTEGER;
  364.    TS : string[1];
  365.  
  366. begin {MONTHCAL}
  367.    VAL(YEARSTR, YEAR, ERROR);
  368.    if (RES = 'Y') or (OUTDEVICE = '5') then
  369.       begin
  370.          for I := 6 to 60 do
  371.             begin
  372.             CAL[I, 6] := CHR(221);
  373.             CAL[I, 76] := CHR(222)
  374.          end;
  375.          for J := 7 to 75 do
  376.             begin
  377.                CAL[10, J] := CHR(196);
  378.                CAL[13, J] := CHR(196)
  379.             end; {for}
  380.          I := 21;
  381.          repeat
  382.             for J := 7 to 75 do
  383.                CAL[I, J] := CHR(196);
  384.             I := I + 8
  385.          until (I > 61);
  386.          J := 16;
  387.          repeat
  388.             for I := 11 to 60 do
  389.                CAL[I, J] := CHR(179);
  390.                J := J + 10
  391.             until (J > 66);
  392.          for J := 6 to 76 do
  393.             begin
  394.                CAL[5, J] := CHR(219);
  395.                CAL[61, J] := CHR(219)
  396.             end; {for}
  397.          I := 10;
  398.          J :=16;
  399.          repeat
  400.             CAL[I, J] := CHR(194);
  401.             J := J + 10
  402.          until (J > 66);
  403.          I := 13;
  404.          J := 16;
  405.          repeat
  406.             repeat
  407.                CAL[I, J] := CHR(197);
  408.                J := J + 10
  409.             until (J > 66);
  410.             J := 16;
  411.             I := I + 8
  412.          until (I > 53);
  413.       end {if}
  414.    else
  415.       begin
  416.          for I := 6 to 60 do
  417.             begin
  418.             CAL[I, 6] := '|';
  419.             CAL[I, 76] := '|'
  420.          end;
  421.          for J := 7 to 75 do
  422.             begin
  423.                CAL[10, J] := '_';
  424.                CAL[13, J] := '_'
  425.             end; {for}
  426.          I := 21;
  427.          repeat
  428.             for J := 7 to 75 do
  429.                CAL[I, J] := '_';
  430.             I := I + 8
  431.          until (I > 61);
  432.          J := 16;
  433.          repeat
  434.             for I := 11 to 60 do
  435.                CAL[I, J] := '|';
  436.                J := J + 10
  437.             until (J > 66);
  438.          for J := 6 to 76 do
  439.             begin
  440.                CAL[5, J] := '*';
  441.                CAL[61, J] := '*'
  442.             end {for}
  443.       end; {else}
  444.    case MONTH of
  445.       1 : MONTHSTR := 'JANUARY';
  446.       2 : MONTHSTR := 'FEBRUARY';
  447.       3 : MONTHSTR := 'MARCH';
  448.       4 : MONTHSTR := 'APRIL';
  449.       5 : MONTHSTR := 'MAY';
  450.       6 : MONTHSTR := 'JUNE';
  451.       7 : MONTHSTR := 'JULY';
  452.       8 : MONTHSTR := 'AUGUST';
  453.       9 : MONTHSTR := 'SEPTEMBER';
  454.       10 : MONTHSTR := 'OCTOBER';
  455.       11 : MONTHSTR := 'NOVEMBER';
  456.       12 : MONTHSTR := 'DECEMBER'
  457.    end; {case}
  458.    START := (80 - ((LENGTH(MONTHSTR) + LENGTH(YEARSTR)) * 2 + 4)) div 2 + 3;
  459.    I := 8;
  460.    J := 1;
  461.    repeat
  462.       CAL[I, START] := MONTHSTR[J];
  463.       J := J + 1;
  464.       START := START + 2
  465.    until (J > LENGTH(MONTHSTR));
  466.    START := START + 3;
  467.    J := 1;
  468.    repeat
  469.       CAL[I, START] := YEARSTR[J];
  470.       J := J + 1;
  471.       START := START + 2
  472.    until (J > LENGTH(YEARSTR));
  473.    if (WEEK = 1) then
  474.       J := 10
  475.    else
  476.       J := (9 - WEEK) * 10;
  477.    for I := 1 to 7 do
  478.       begin
  479.          case I of
  480.             1 : begin
  481.                    CAL[12, J] := 'S'; CAL[12, J+1] := 'U'; CAL[12, J+2] := 'N'
  482.                 end;
  483.             2 : begin
  484.                    CAL[12, J] := 'M'; CAL[12, J+1] := 'O'; CAL[12, J+2] := 'N'
  485.                 end;
  486.             3 : begin
  487.                    CAL[12, J] := 'T'; CAL[12, J+1] := 'U'; CAL[12, J+2] := 'E'
  488.                 end;
  489.             4 : begin
  490.                    CAL[12, J] := 'W'; CAL[12, J+1] := 'E'; CAL[12, J+2] := 'D'
  491.                 end;
  492.             5 : begin
  493.                    CAL[12, J] := 'T'; CAL[12, J+1] := 'H'; CAL[12, J+2] := 'U'
  494.                 end;
  495.             6 : begin
  496.                    CAL[12, J] := 'F'; CAL[12, J+1] := 'R'; CAL[12, J+2] := 'I'
  497.                 end;
  498.             7 : begin
  499.                    CAL[12, J] := 'S'; CAL[12, J+1] := 'A'; CAL[12, J+2] := 'T'
  500.                 end
  501.          end;
  502.          J := (J + 10) mod 70;
  503.          if (J < 10) then
  504.             J := 70
  505.       end;
  506.    M := MONTH - 2;
  507.    if M <= 0 then
  508.       M := M + 12;
  509.    C := YEAR div 100;
  510.    L := 0;
  511.    if (YEAR mod 4) = 0 then
  512.       L := 1;
  513.    if ((YEAR mod 100) = 0) and ((YEAR mod 400) <> 0) then
  514.       L := 0;
  515.    Y := YEAR mod 100;
  516.    D1 := N + TRUNC(2.6 * M - 0.2) + Y + (Y div 4) + (C div 4);
  517.    D2 := 2 * C + (1 + L) * (M div 11);
  518.    if (WEEK = 1) then
  519.       D := 1 + (D1 - D2) mod 7
  520.    else
  521.       D := ((9 - WEEK) + (D1 - D2)) mod 7;
  522.    if (D < 1) then
  523.       D := D + 7;
  524.    case MONTH of
  525.       1, 3, 5, 7, 8, 10, 12 : DAYS := 31;
  526.       2 : if L = 1 then
  527.              DAYS := 29
  528.           else
  529.              DAYS := 28;
  530.       4, 6, 9, 11 : DAYS := 30
  531.    end; {case}
  532.    START := (D * 10) + 3;
  533.    I := 15;
  534.    J := START;
  535.    DAY := 1;
  536.    repeat
  537.       if ((DAY div 10) <> 0) then
  538.          begin
  539.             TEMP := DAY div 10;
  540.             STR(TEMP:1, TS);
  541.             CAL[I, J] := TS
  542.          end; {if}
  543.       TEMP := DAY mod 10;
  544.       STR(TEMP:1, TS);
  545.       CAL[I, J + 1] := TS;
  546.       DAY := DAY + 1;
  547.       J := J + 10;
  548.       if J > 74 then
  549.          begin
  550.             I := I + 8;
  551.             J := 13
  552.          end {if}
  553.    until (DAY > DAYS);
  554.    for I := 1 to 4 do
  555.       WRITELN(OUTFILE);
  556.    for I := 5 to 61 do
  557.       begin
  558.          for J := 1 to 76 do
  559.             WRITE(OUTFILE, CAL[I, J]);
  560.          WRITELN(OUTFILE)
  561.       end; {for}
  562.    if (OUTDEVICE in ['6', '7']) then
  563.       WRITE(OUTFILE, #12);
  564.    INITIALIZE
  565. end; {MONTHCAL}
  566.  
  567. {------------------------------------------------------------------------------}
  568.  
  569. procedure DEVICE;
  570.  
  571. {Select output device.}
  572.  
  573. var
  574.    I : INTEGER;
  575.    DISKDRIVE : CHAR;
  576.    OUTFILENAME : string[14];
  577.  
  578. begin {DEVICE}
  579.    CLRSCR;
  580.    DRAW_WINDOW(12, 6, 68, 19);
  581.    GOTOXY(35, 9);
  582.    WRITE('Output Options');
  583.    GOTOXY(35, 10);
  584.    for I := 1 to 14 do
  585.       WRITE(CHR(196));
  586.    GOTOXY(19, 12);
  587.    WRITELN('<F5>  =  Preview calendar(s) on the screen'); GOTOXY(19, 14);
  588.    WRITELN('<F6>  =  Print calendar(s) from the printer'); GOTOXY(19, 16);
  589.    WRITELN('<F7>  =  Transfer calendar(s) to a file');
  590.    repeat
  591.       GOTOXY(20, 22);
  592.       WRITE('Press function key indicating your choice');
  593.       READFK(OUTDEVICE, 63, 65);
  594.       OUTDEVICE := UPCASE(OUTDEVICE)
  595.    until (OUTDEVICE in ['5', '6', '7']);
  596.    WRITELN;
  597.    case OUTDEVICE of
  598.       '5' : begin
  599.                ASSIGN(OUTFILE, 'CON:');
  600.                CLRSCR
  601.             end;
  602.       '6' : begin
  603.                ASSIGN(OUTFILE, 'LST:');
  604.                WRITELN; WRITELN;
  605.                if (RES = '?') and (CHOICE <> '3') then
  606.                   begin
  607.                      CLRSCR;
  608.                      for I := 1 to 10 do
  609.                         WRITELN;
  610.                      repeat
  611.                         GOTOXY(17, 12);
  612.                         WRITE('Is your printer IBM Graphics compatible (Y/N)? >');
  613.                         CLREOL;
  614.                         READCH(RES);   RES := UPCASE(RES)
  615.                      until (RES in ['N', 'Y'])
  616.                   end;
  617.                CLRSCR
  618.             end;
  619.       '7' : begin {set up output file}
  620.                repeat
  621.                   CLRSCR;
  622.                   GOTOXY(20, 9);
  623.                   OUTFILENAME := '';
  624.                   WRITELN('Enter the NAME of the text file to which you');
  625.                   WRITE(' ':19, 'want the calendar(s) transferred >');
  626.                   READLN(OUTFILENAME);
  627.                   repeat
  628.                      GOTOXY(20, 12);
  629.                      WRITELN('Which DISK DRIVE will contain the');
  630.                      WRITE(' ':19, 'file disk (A/B/C)? >');
  631.                      CLREOL;
  632.                      READCH(DISKDRIVE);  WRITELN;
  633.                      DISKDRIVE := UPCASE(DISKDRIVE)
  634.                   until (DISKDRIVE in ['A', 'B', 'C']);
  635.                   OUTFILENAME := CONCAT(DISKDRIVE, ':', OUTFILENAME);
  636.                   WRITELN;
  637.                   GOTOXY(20, 15);
  638.                   WRITE('File name:  ', OUTFILENAME);
  639.                   repeat
  640.                      GOTOXY(20, 16);
  641.                      WRITE('Is this correct (Y/N)? >'); CLREOL;
  642.                      READCH(RESPONSE);
  643.                      RESPONSE := UPCASE(RESPONSE)
  644.                   until (RESPONSE in ['Y', 'N'])
  645.                until (RESPONSE = 'Y'); {data entered is correct}
  646.                if (RES = '?') and (CHOICE <> '3') then
  647.                   repeat
  648.                      GOTOXY(20, 18);
  649.                      WRITE('Is your printer IBM Graphics compatible (Y/N)? >');
  650.                      CLREOL;
  651.                      READCH(RES);
  652.                      RES := UPCASE(RES)
  653.                   until (RES in ['N', 'Y']);
  654.                ASSIGN(OUTFILE, OUTFILENAME);
  655.                CLRSCR;
  656.                GOTOXY(26, 12);
  657.                WRITE('writing to file ', OUTFILENAME, ' ...')
  658.             end
  659.    end; {case}
  660.    REWRITE(OUTFILE);
  661. end; {DEVICE}
  662.  
  663.  
  664. {------------------------------------------------------------------------------}
  665.  
  666. procedure MENU;
  667.  
  668. {Select and define calendar.}
  669.  
  670. var
  671.    MONSTR : string[2];
  672.    ERROR,
  673.    I, J : INTEGER;
  674.  
  675. {---------------------------------------------------------}
  676.  
  677. procedure CAL_WEEK;
  678.  
  679. {Select calendar week.}
  680.  
  681. var
  682.    WEEKCH : CHAR;
  683.    I : INTEGER;
  684.  
  685. begin
  686.    CLRSCR;
  687.    DRAW_WINDOW(24, 2, 55, 21);
  688.    GOTOXY(29, 4);  WRITE('Calendar Week Options');
  689.    GOTOXY(29, 5);
  690.    for I := 1 to 21 do
  691.       WRITE(CHR(196));
  692.    GOTOXY(28, 7);  WRITE('1. Sunday to Saturday');
  693.    GOTOXY(28, 9);  WRITE('2. Monday to Sunday');
  694.    GOTOXY(28, 11); WRITE('3. Tuesday to Monday');
  695.    GOTOXY(28, 13); WRITE('4. Wednesday to Tuesday');
  696.    GOTOXY(28, 15); WRITE('5. Thursday to Wednesday');
  697.    GOTOXY(28, 17); WRITE('6. Friday to Thursday');
  698.    GOTOXY(28, 19); WRITE('7. Saturday to Friday');
  699.    repeat
  700.       GOTOXY(22, 24);
  701.       WRITE('Enter desired calendar week (1-7) >');
  702.       CLREOL;
  703.       READLN(WEEKCH);
  704.    until (WEEKCH in ['1'..'7']);
  705.    VAL(WEEKCH, WEEK, ERROR);
  706. end;
  707.  
  708. {---------------------------------------------------------}
  709.  
  710. begin {MENU}
  711.    DRAW_WINDOW(5, 3, 75, 19); GOTOXY(32, 6);
  712.    WRITE('M A I N   M E N U');
  713.    GOTOXY(32, 7);
  714.    for I := 1 to 17 do
  715.       WRITE(CHR(196));
  716.    GOTOXY(11, 10);
  717.    WRITE('<F1>  =  Create a calendar for a single month');
  718.    GOTOXY(11, 12);
  719.    WRITE('<F2>  =  Create calendars for each month of an entire year');
  720.    GOTOXY(11, 14);
  721.    WRITE('<F3>  =  Create a single calendar showing an entire year');
  722.    GOTOXY(11, 16);
  723.    WRITE('<F4>  =  Quit');
  724.    repeat
  725.       GOTOXY(19, 22);
  726.       WRITE('Press function key indicating your choice');
  727.       READFK(CHOICE, 59, 62);
  728.    until (CHOICE in ['1'..'4']);
  729.    CLRSCR;
  730.    if CHOICE = '1' then
  731.       begin
  732.          DRAW_WINDOW(30, 4, 50, 19);
  733.          GOTOXY(34, 6);  WRITE(' 1. January');
  734.          GOTOXY(34, 7);  WRITE(' 2. February');
  735.          GOTOXY(34, 8);  WRITE(' 3. March');
  736.          GOTOXY(34, 9);  WRITE(' 4. April');
  737.          GOTOXY(34, 10); WRITE(' 5. May');
  738.          GOTOXY(34, 11); WRITE(' 6. June');
  739.          GOTOXY(34, 12); WRITE(' 7. July');
  740.          GOTOXY(34, 13); WRITE(' 8. August');
  741.          GOTOXY(34, 14); WRITE(' 9. September');
  742.          GOTOXY(34, 15); WRITE('10. October');
  743.          GOTOXY(34, 16); WRITE('11. November');
  744.          GOTOXY(34, 17); WRITE('12. December');
  745.          repeat
  746.             GOTOXY(30, 22);
  747.             WRITE('Enter MONTH (1-12) >');
  748.             CLREOL;
  749.             READLN(MONSTR);
  750.             VAL(MONSTR, MONTH, ERROR)
  751.          until (ERROR = 0) and (MONSTR <> '') and (MONTH in [1..12]);
  752.          WRITELN;
  753.          repeat
  754.             GOTOXY(28, 24);
  755.             WRITE('Enter YEAR (1600-2400) >');
  756.             CLREOL;
  757.             READLN(YEARSTR);
  758.             VAL(YEARSTR, YEAR, ERROR)
  759.          until (YEAR > 1599) and (YEAR < 2401) and (ERROR = 0) and
  760.                (YEARSTR <> '');
  761.          CAL_WEEK;
  762.          DEVICE;
  763.          MONTHCAL(MONTH)
  764.       end
  765.    else if (CHOICE = '2') then
  766.       begin
  767.          repeat
  768.             GOTOXY(28, 12);
  769.             WRITE('Enter YEAR (1600-2400) >');
  770.             CLREOL;
  771.             READLN(YEARSTR);
  772.             VAL(YEARSTR, YEAR, ERROR)
  773.          until (ERROR = 0) and (YEAR > 1599) and (YEAR < 2401) and
  774.                (YEARSTR <> '');
  775.          CAL_WEEK;
  776.          DEVICE;
  777.          for MONTH := 1 to 12 do
  778.             MONTHCAL(MONTH);
  779.       end {2}
  780.    else if (CHOICE = '3') then
  781.       begin
  782.          repeat
  783.             GOTOXY(28, 12);
  784.             WRITE('Enter YEAR (1600-2400) >');
  785.             CLREOL;
  786.             READLN(YEARSTR);
  787.             VAL(YEARSTR, YEAR, ERROR)
  788.          until (ERROR = 0) and (YEAR > 1599) and (YEAR < 2401) and
  789.                (YEARSTR <> '');
  790.          CAL_WEEK;
  791.          DEVICE;
  792.          YEARCAL;
  793.       end; {3}
  794.    CLOSE(OUTFILE)
  795. end; {MENU}
  796.  
  797. {------------------------------------------------------------------------------}
  798.  
  799. begin {MAIN PROGRAM}
  800.    RES := '?';
  801.    CLRSCR;
  802.    DRAW_WINDOW(26, 1, 54, 17);
  803.    GOTOXY(36, 3);  WRITE('INSTACAL');
  804.    GOTOXY(34, 4);  WRITE('(version 2.2)');
  805.    GOTOXY(27, 5);  for I := 1 to 27 do WRITE('_');
  806.    I := 7;
  807.    while (I <= 16) do
  808.       begin
  809.          J := 27;
  810.          while (J <= 53) do
  811.             begin
  812.                GOTOXY(J, I);
  813.                WRITE(CHR(196));
  814.                J := J + 1
  815.             end;
  816.          I := I + 2
  817.       end;
  818.    J := 30;
  819.    while (J <= 50) do
  820.       begin
  821.          I := 6;
  822.          while(I <= 16) do
  823.             begin
  824.                GOTOXY(J, I);
  825.                WRITE(CHR(179));
  826.                I := I + 1
  827.             end;
  828.          J := J + 4
  829.       end;
  830.    GOTOXY(28, 6); WRITE('s');
  831.    GOTOXY(32, 6); WRITE('m');
  832.    GOTOXY(36, 6); WRITE('t');
  833.    GOTOXY(40, 6); WRITE('w');
  834.    GOTOXY(44, 6); WRITE('t');
  835.    GOTOXY(48, 6); WRITE('f');
  836.    GOTOXY(52, 6); WRITE('s');
  837.    GOTOXY(26, 20); WRITE('INSTAnt CALendar generator by');
  838.    GOTOXY(34, 22); WRITE('Jim Shellem');
  839.    GOTOXY(34, 23); WRITE('Woodlyn, PA');
  840.    GOTOXY(33, 24); WRITE('Copyright 1988');
  841.    delay(4000);
  842.    INITIALIZE;
  843.    repeat
  844.       CLRSCR;
  845.       MENU
  846.    until (CHOICE = '4');
  847.    CLRSCR;
  848. end.
  849.